home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / modules / debugmod.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  3.1 KB  |  86 lines
  1. (***************************************************************************
  2.  
  3.     DEBUGMOD.SML: utility functions to debug modules and functors
  4.  
  5.  ***************************************************************************)
  6.  
  7. signature DEBUGMOD = sig
  8.  
  9.   val getFctArg : Modules.functorVar * Modules.Structure
  10.           -> Symbol.symbol option * Modules.Structure
  11.  
  12.   datatype fctcontext
  13.    = FCTCONTEXT of {fct : Modules.functorVar,
  14.             str : Modules.Structure,
  15.             next_context : (unit -> fctcontext)}
  16.    | NOFCTCONTEXT
  17.  
  18.   val deabstyc : (unit -> fctcontext) -> Types.tycon -> Types.tycon
  19.   val deabsstr : (unit -> fctcontext) -> Modules.Structure -> Modules.Structure
  20.  
  21. end
  22.  
  23. structure DebugMod:DEBUGMOD = struct
  24.  
  25. local 
  26.   open Modules Extern SigMatch ErrorMsg Stamps
  27. in
  28.  
  29. (* RECONSTRUCTION OF THE FUNCTOR ARGUMENT *)
  30.  
  31. (* GetFctArg: get the constrained actual argument for the application 
  32.               and the argument name *)
  33.  
  34. fun getFctArg (FCTvar{binding=fct,...},str) =
  35.   let (* gives back NONE for anonymous functor parameter the name otherwise *)
  36.       fun normalize_name name = if name = name_X then NONE else SOME name
  37.       (* extract the parent, the argument signature and the parameter name
  38.      of a functor by going up to the original definition *)
  39.       fun functor_origin (fct as FCT{argument,parent,paramName,...}) = 
  40.         (parent,argument,normalize_name paramName)
  41.       (* The recursive call shouldn't be necessary because it is an
  42.          invariant in the present state that there is only one level
  43.          of functor instance *)
  44.     | functor_origin (FCT_INSTANCE{fct,...}) = functor_origin fct
  45.     | functor_origin _ = impossible "functor_origin"
  46.       val (parent,arg_sig,paramName) = functor_origin fct
  47.       fun error _ msg = impossible ("getFctArg: error during match:"^msg)
  48.       (* build the argument pair *)
  49.       val argument =   make_argument{parent=parent,parameter=str}
  50.       (* The stamp scope is wrong but abstract and self are false.
  51.      err is the off_line error message but useless because we know
  52.      we have already matched this
  53.      It is also why we don't need an environment *)
  54.       val (coerced_argument,_) =
  55.              match{abstract=false, self=false, err=error, arg_option=NONE,
  56.                    printEnv=Env.empty, scope=freeScope, spath=[],
  57.                    str=argument, sign=arg_sig}
  58.       (* extract the parameter from an argument pair *)
  59.       fun extract_parameter (INSTANCE{sign as SIG{env,...},subStrs,...}) = ((
  60.         case Env.look(!env,name_X)
  61.         of (STRbind (STRvar {binding=STR_FORMAL {pos, ...},...})) =>
  62.           Array.sub(subStrs,pos)
  63.            | _ => impossible "getFctArg 1")
  64.         handle Env.Unbound => impossible "getFctArg 3")
  65.         | extract_parameter _ = impossible "getFctArg 2"
  66.       val coerced_param = extract_parameter coerced_argument
  67.   in (paramName, coerced_param) end
  68.  
  69. (* DEABSTRACTION OF THE FUNCTOR BODY *)
  70.  
  71. (* Context for deabstraction *)
  72. datatype fctcontext
  73.   = FCTCONTEXT of {fct : functorVar,
  74.            str : Structure,
  75.            next_context : (unit -> fctcontext)}
  76.   | NOFCTCONTEXT
  77.  
  78. (* type deabstraction *)
  79. fun deabstyc next_context tyc = tyc
  80.  
  81. (* structure deabstraction *)
  82. fun deabsstr next_context str = str
  83.  
  84. end
  85. end
  86.